home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / READ._c < prev    next >
Text File  |  1990-06-10  |  23KB  |  909 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "files.h"
  22. #include "maxvars.h"
  23.  
  24. /* 
  25.  
  26. [6]  READIN
  27. ReadIn reads a Prolog sentence from the current input file and builds a
  28. term from it.  The sentence is parsed using a shift- reduce parsing
  29. algorithm which depends on operator information in atom entries.
  30.  
  31. */
  32.  
  33.  
  34. IMPORT TERM A0,A1;
  35. IMPORT char CH,LASTCH;   /* from linebuffer.c */
  36. IMPORT void ABORT(),ERROR(),SYSTEMERROR(),SYNERROR();      
  37. IMPORT int ERRPOS;
  38. IMPORT boolean WARNFLAG;
  39. IMPORT ATOM LOOKUP(),LOOKATOM();
  40. IMPORT boolean In_Toplevel_Read;
  41. IMPORT TERM LISTREP();
  42. IMPORT boolean UNIFY();
  43. IMPORT boolean unget,ECHOFLAG;
  44. IMPORT int FirstCharPos;
  45. IMPORT void fillbuffer();
  46.  
  47. LOCAL boolean FILEENDED(void)
  48. {
  49. if(!unget && CHARPOS >=LINELENGTH && !ISTTY(inputfile))
  50.  fillbuffer();
  51. return (!unget && ISEOF(inputfile) && (CHARPOS >=LINELENGTH));
  52. }
  53.  
  54. /* Get the next character of the current input file in 'ch'. */
  55. /* inline-code in READIN */
  56. LOCAL void GETCHAR(void)
  57. { 
  58.   if(unget){unget=false; return;}
  59.   LASTCH=CH;
  60.   if(FILEENDED()){CH= '\n'; return; }
  61.   if( CHARPOS >=LINELENGTH ){
  62.      /* no char's in the buffer */
  63.      fillbuffer();
  64.      }
  65.   CH=LINEBUF[CHARPOS++] ;if(ECHOFLAG)wc(CH);
  66.   if(CH== '\n') {FirstCharPos=CHARPOS ; ERRPOS=0; LINENUMBER++;}
  67. }
  68.  
  69. LOCAL boolean LINEENDED(void)
  70. { if(CHARPOS >=LINELENGTH && !ISTTY(inputfile))
  71.  fillbuffer();
  72.   return (FILEENDED() || LINEBUF[CHARPOS]== '\n');
  73. }
  74.  
  75. LOCAL void REGET(void)
  76. { unget=true;
  77. }
  78.  
  79. #if !BIT8
  80. #define STRINGSPACE 256 /* Size of string buffer. */
  81. #endif
  82. #if BIT8
  83. #define STRINGSPACE 128 /* Size of string buffer. */
  84. #endif
  85.  
  86. LOCAL char ATOMTAB[STRINGSPACE+1]; /* also used in help.c */
  87.  
  88. LOCAL int ATOMINDEX;
  89.  
  90. LOCAL void ATOMCHAR (register char C)
  91. { if(ATOMINDEX>=STRINGSPACE) ERROR(aSTRINGSPACEE);
  92.   ATOMTAB[ATOMINDEX++]=C;
  93. }
  94.  
  95. /*
  96. EXPORT TERM READIN();
  97. EXPORT boolean DOREAD();
  98. EXPORT TERM VARTERM();
  99. EXPORT int VARCOUNT;
  100. EXPORT PREC LPREC(),RPREC();
  101. EXPORT CHARCLAS[];
  102. */
  103.  
  104. #if BIT32
  105. #define READSIZE 2000      /* Size of stack */
  106. #define READDEPTH 1000    /* Max. nesting depth */
  107. #endif
  108. #if BIT16
  109. #define READSIZE  250 
  110. #define READDEPTH 250
  111. #endif
  112. #if BIT8
  113. #define READSIZE 50
  114. #define READDEPTH 50
  115. #endif
  116.  
  117. #if BIT8
  118. #define VARLIMIT   100
  119. #endif
  120. #if BIT16
  121. #define VARLIMIT   200
  122. #endif
  123. #if BIT32
  124. #define VARLIMIT  2000
  125. #endif
  126.  
  127. #define RBRACE '}'
  128.  
  129. /* characters are classified as follows:
  130.    small letters  a..z:      SC 
  131.    large letters  A..Z_:   BC 
  132.    digits 0..9:              DC
  133.    spaces                    C0
  134.    atomic characters         OC
  135.    special characters ( ) ' " [ ] { }  |  , 
  136.    are coded by itself
  137.    and all other characters are coded as  0
  138. */
  139.  
  140. #define SC 1
  141. #define BC 2
  142. #define DC 3
  143. #define OC 4
  144. #define C0 5 
  145.  
  146. char CHARCLASS[256]=
  147.  
  148. /*      0   1   2   3   4   5   6   7   8   9   A   B   C   D   E   F */
  149. /*--------------------------------------------------------------------*/
  150. /*0*/ { C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0,
  151. /*1*/   C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0, C0,
  152. /*2*/   C0,'!','"', OC, SC, OC,OC,'\'','(',')', OC, OC,',', OC, OC, OC,
  153. /*3*/   DC, DC, DC, DC, DC, DC, DC, DC, DC, DC, OC, OC, OC, OC, OC, OC,
  154. /*4*/   OC, BC, BC, BC, BC, BC, BC, BC, BC, BC, BC, BC, BC, BC, BC, BC,
  155. /*5*/   BC, BC, BC, BC, BC, BC, BC, BC, BC, BC, BC,'[', OC,']', OC, BC,
  156. /*6*/   OC, SC, SC, SC, SC, SC, SC, SC, SC, SC, SC, SC, SC, SC, SC, SC,
  157. /*7*/   SC, SC, SC, SC, SC, SC, SC, SC, SC, SC, SC,'{','|','}','~', C0 };
  158.  
  159.  
  160. #define isdigit(CH)      (CHARCLASS[CH]==DC )
  161.  
  162. /* The precedence for a left operand of a. */
  163. GLOBAL PREC LPREC (ATOM A)
  164. { switch (oclass(A))
  165.   { case XFO:
  166.     case XFXO:
  167.     case XFYO:
  168.       return oprec(A)-1;
  169.     default:
  170.       return oprec(A);
  171.   }
  172. }
  173.  
  174. /* The precedence for a right operand of a. */
  175. GLOBAL PREC RPREC (ATOM A)
  176. { switch (oclass(A))
  177.   { case FXO:
  178.     case XFXO:
  179.     case YFXO:
  180.       return oprec(A)-1;
  181.     default:
  182.       return oprec(A);
  183.   }
  184. }
  185.  
  186. /*
  187.    Input and parse a Prolog sentence and build a term from it.  The
  188.    finite state part of the parser is characterized by the variables
  189.    'context' and 'expected'.
  190.    'context' indicates the construct being parsed:
  191.       outerK       The outermost level of a sentence.
  192.       innerK       An expression in parentheses.
  193.       funcK        The arguments of a functor.
  194.       listK        The elements of a list.
  195.       endlistK     A list continuation (between '|' or ',..'
  196.                    and ']' in a list).
  197.       curlyK       An expression in curly brackets.
  198.    'expected' indicates whether the next symbol is to be an operator
  199.    (opX) or an operand (randX).
  200.    Two stacks are used: one, represented by the array 'stack', to hold
  201.    parts of incompletely parsed terms, the other, represented by the
  202.    array 'statestack', to hold contextual information during parsing of
  203.    nested constructs. In fact, the parsing algorithm corresponds to a
  204.    stack machine with a single stack, but two stacks are used only as a
  205.    matter of convenience.
  206. */
  207.  
  208. #define OUTERK 0
  209. #define INNERK 1
  210. #define FUNCK 2
  211. #define LISTK 3
  212. #define ENDLISTK 4
  213. #define CURLYK 5
  214. #define STATE  int
  215.  
  216. #define TERML 0
  217. #define OPL 1
  218. #define FUNCL 2
  219. #define MARKL 3
  220. #define ELEMTAG int
  221.  
  222. LOCAL STATE  CONTEXT;
  223. LOCAL boolean OPEXPECTED; 
  224. LOCAL PREC  HIPREC, LOPREC;
  225. LOCAL int  RTOP;
  226.  
  227. LOCAL TERM TSTACK[READSIZE];
  228. LOCAL ATOM ASTACK[READSIZE];
  229. LOCAL ELEMTAG TAGSTACK[READSIZE];
  230.  
  231. LOCAL void RPOP(register ATOM *PA, register TERM *PT)
  232. { *PA=ASTACK[RTOP]; *PT=TSTACK[RTOP]; RTOP--; }
  233.  
  234. LOCAL void RPUSH (register ELEMTAG T, register ATOM A, register TERM X)
  235. { if(RTOP>=READSIZE) SYNERROR(READSTACKE);
  236.   RTOP++;
  237.   TAGSTACK[RTOP]=T; ASTACK[RTOP]=A; TSTACK[RTOP]=X;
  238. }
  239.  
  240. LOCAL  int STOP;
  241. LOCAL  int READCONTEXT[READDEPTH],
  242.             READPREC[READDEPTH];
  243.  
  244. LOCAL void SAVECONTEXT(void)
  245. { if(STOP>=READDEPTH) SYNERROR(READNESTE);
  246.   READCONTEXT[STOP]=CONTEXT; READPREC[STOP]=HIPREC; STOP++;
  247. }
  248.  
  249. LOCAL void RESTORECONTEXT(void)
  250. { STOP--; CONTEXT=READCONTEXT[STOP]; HIPREC=READPREC[STOP];
  251. }
  252.  
  253. int  VARCOUNT;
  254. /*
  255. LOCAL  struct 
  256.   { string aIDENT; 
  257.     TERM  ROOTVAR;
  258.      int counter;} VARTABLE[MAXVARS];
  259. */
  260. LOCAL string aIDENT[MAXVARS];
  261. /*LOCAL*/ TERM VAR_TAB[MAXVARS]; /* also used in write.c */
  262. LOCAL int counter[MAXVARS];
  263.  
  264. TERM VARTERM(void)
  265. { TERM Q,R; int I;
  266.   if(VARCOUNT==0) return nil_term;
  267.   R=nil_term;
  268.   for(I=VARCOUNT-1; 0<=I; I--)
  269.     { Q=mk2sons(LOOKUP(aIDENT[I],0,false),nil_term,
  270.                  VART,VAR_TAB[I]);
  271.       if(non_nil_term(R))  R=mkfunc(NL_2,mk2sons(ISEQ_2,Q,VART,R));
  272.       else R=mkfunc(ISEQ_2,Q);
  273.     }
  274.   if(non_nil_term(R))
  275.     { Q=mk2sons(WRITE_1,R,GOTO_1,
  276.                  mk2sons(NOT_1,mkfunc(ASK_1,mkint(59)),nil_atom,nil_term));
  277.       return Q;
  278.     }
  279.   return nil_term;
  280. }
  281.  
  282.  
  283. /*
  284.       Collapse items on the stack. Before each reduction step, the
  285.       operator a on top of the stack is "balanced" against the
  286.       precedences p=b@.oprec and lp=Lprec(b) of a new operator b,
  287.       to see if a could be a left operand of b, or b a right operand of
  288.       a. If neither is possible or both are possible, a precedence
  289.       conflict is reported.  If only the first is possible, a reduction
  290.       step is taken. If only the second is possible, reduction is
  291.       complete.
  292. */
  293.  
  294. LOCAL void REDUCE (PREC P, PREC LP)
  295. { TERM  X, Y;
  296.   ATOM  A,XA,YA;
  297.   RPOP(&XA,&X);
  298.   while(TAGSTACK[RTOP]==OPL)
  299.     { A=ASTACK[RTOP];
  300.       if(RPREC(A)>=P)
  301.         if(oprec(A)<=LP) SYNERROR(PRECE);
  302.         else break;
  303.       else
  304.         if(oprec(A)>LP) SYNERROR(PRECE);
  305.         else 
  306.         { RTOP--;
  307.           switch (oclass(A)) 
  308.           { case FXO:
  309.             case FYO:
  310.               X=mkfunc(XA,X); XA=A; 
  311.               break;
  312.             case XFXO:
  313.             case XFYO:
  314.             case YFXO:
  315.               RPOP(&YA,&Y); X=mk2sons(YA,Y,XA,X); XA=A; break;
  316.             case XFO:
  317.             case YFO:break;
  318.             case NONO: break;
  319.             default: SYSTEMERROR("REDUCE");
  320.           }
  321.         }
  322.     }
  323.   RPUSH(TERML,XA,X); 
  324. }
  325.  
  326. /*
  327.       Attempt to force the state required for a delimiter.
  328.       This state must satisfy the predicate
  329.          (expected=opX) and (context in s).
  330.       If initially (expected=randX) and the top item on the stack
  331.       is a prefix operator, this operator is converted to an atom.
  332.       This allows for constructions such as (?-) in which a prefix
  333.       operator occurs as an atom.
  334. */
  335.  
  336. LOCAL void CHECKDELIM (void)
  337. { ATOM  A; TERM X;
  338.   if(!OPEXPECTED)
  339.     { if(TAGSTACK[RTOP]!=OPL) SYNERROR(NEEDRANDE);
  340.       RPOP(&A,&X);
  341.       if(oclass(A)!=FXO && oclass(A)!=FYO) SYNERROR(NEEDRANDE);
  342.       RPUSH(TERML,LOOKATOM(A,0),nil_term); 
  343.     }
  344.   REDUCE(MAXPREC,MAXPREC);
  345. }
  346.  
  347. /* Process an atom. */
  348.  
  349. LOCAL void SQUASHRAND (ATOM A)
  350. { PREC  P, LP;
  351.   P=oprec(A);
  352.   LP=LPREC(A);
  353.   if(LP<LOPREC ||
  354.       (P>SUBPREC && 
  355.         CONTEXT!=OUTERK && CONTEXT!=INNERK && CONTEXT!=CURLYK))
  356.     SYNERROR(PRECE);
  357.   REDUCE(P,LP);
  358. }
  359.  
  360. /* Read an atom or string quoted by 'q' and store its characters
  361.       in the atom table, translating pairs of embedded quotes. */
  362.  
  363. LOCAL void SCANQUOTE (char Q)
  364. { 
  365.   ATOMINDEX=0; 
  366.   for(;;)
  367.   { 
  368.     if(CH==Q)
  369.       { GETCHAR(); if(CH!=Q) return; }
  370.     if(CH=='\\') 
  371.       { int suM; 
  372.  GETCHAR();
  373.  switch(CH)
  374.  { case 'n': CH='\n'; break;
  375.    case 'r': CH='\r'; break;
  376.    case 'b': CH='\b'; break;
  377.    case 't': CH='\t'; break;
  378.    case 'f': CH='\f'; break;
  379.    case 'v': CH='\v'; break;
  380.    case 'a': CH='\007';break;
  381.    case '\\': CH= '\\';break;
  382.    default:
  383.              if(CHARCLASS[CH]!=DC)break;
  384.              sum=CH - '0';
  385.              GETCHAR();
  386.              if(CHARCLASS[CH] !=DC)
  387.              {
  388.                  if(ATOMINDEX>=STRINGSPACE) ERROR(aSTRINGSPACEE);
  389.                  ATOMTAB[ATOMINDEX++]=sum;
  390.          continue;
  391.              }
  392.              sum=sum * 8 + CH - '0';
  393.              GETCHAR();
  394.              if(CHARCLASS[CH] !=DC)
  395.              {
  396.                  if(ATOMINDEX>=STRINGSPACE) ERROR(aSTRINGSPACEE);
  397.                  ATOMTAB[ATOMINDEX++]=sum;
  398.          continue;
  399.              }
  400.              sum=sum * 8 + CH - '0';
  401.              CH= (char)(sum & 0377);break;
  402.  
  403.  }
  404.       }
  405.     if(ATOMINDEX>=STRINGSPACE) ERROR(aSTRINGSPACEE);
  406.     ATOMTAB[ATOMINDEX++]=CH;
  407.     GETCHAR();
  408.   }
  409. }
  410.  
  411. /* Enter a variable and return it as a term. */
  412.  
  413. /* variable handling */
  414.  
  415. LOCAL int VARHWM;
  416. LOCAL TERM ENTERVAR (void)
  417. { TERM  V;
  418.   int  N=0,NEWINDEX;
  419. static char vtab[VARLIMIT];
  420.   string NEWVAR;
  421.   NEWVAR= &vtab[VARHWM]; NEWINDEX=VARHWM;
  422.   vtab[NEWINDEX++]=LASTCH;
  423.   while(SC<=CHARCLASS[CH] && CHARCLASS[CH]<=DC)
  424.     { if(NEWINDEX>=VARLIMIT) ABORT(VARSPACEE);
  425.       vtab[NEWINDEX++]=CH;
  426.       GETCHAR(); 
  427.     }
  428.   vtab[NEWINDEX++]=0;
  429.   while(N!=VARCOUNT)
  430.   { N++;
  431.     if(strcmp(aIDENT[N-1],NEWVAR)==0){
  432.       counter[N-1]++;
  433.       return VAR_TAB[N-1];}
  434.   }
  435.   if(VARCOUNT>=MAXVARS) SYNERROR(NVARSE);
  436.   VARCOUNT++;
  437.   VARHWM=NEWINDEX;  
  438.   V=mkfreevar();
  439.   aIDENT[VARCOUNT-1]=NEWVAR;
  440.   VAR_TAB[VARCOUNT-1]=V;
  441.   counter[VARCOUNT-1]=1;
  442.   return V;
  443. }
  444.  
  445. LOCAL void Var_Check(void)
  446. { int i;
  447.   /* check if a variable is only used only at one time */
  448.   for(i=0;i<VARCOUNT;i++)
  449.     if(counter[i]==1)
  450.       { ws("WARNING: "); ws(aIDENT[i]); ws(" used only once ! \n"); }
  451. }
  452.  
  453. #if REALARITH
  454. LOCAL REAL genreal(REAL r, int expo)
  455. {while(expo >=10 ) {expo-=10; r *=1e10;}
  456.  while(expo >=1){ expo-- ; r *=10.0; }
  457.  while(expo <= -10 ){expo +=10; r *=1e-10;}
  458.  while(expo <= -1) { expo ++ ; r *=0.1;}
  459.  return r;
  460. }
  461. #endif
  462.  
  463. #if REALARITH && LONGARITH
  464. LOCAL TERM readnumber(boolean sign)
  465. {LONG l ; int  i ; REAL r ;
  466.  boolean esign=false;
  467.  int expo=0;
  468.  l= (LONG)(i=LASTCH-'0');
  469.  r= (REAL)i;
  470.  while(isdigit(CH)){
  471.  l=l * 10l  + (LONG)(CH -'0');
  472.  i=i * 10   + (CH -'0');
  473.  r=r * 10.0 + (REAL)(CH -'0');
  474.  GETCHAR();
  475.  }
  476.   GETCHAR();
  477.   if(LASTCH== '.' && isdigit(CH))goto double1;
  478.   if((LASTCH== 'e' || LASTCH== 'E') &&
  479.      (isdigit(CH)||CH== '+'||CH=='-'))goto double2;
  480.   /* a normal integer */
  481.   REGET();
  482.   if( l <=  r-0.5) {
  483.  /* converting integer to real */
  484.  if(WARNFLAG)ws("WARNING: converting integer to real\n");
  485.  return mkreal(sign ? -r : r);
  486.  }
  487.   if(i==l){
  488.  /* a normal integer */
  489.  return mkint(sign ? -i : i);
  490.  }
  491.   else {
  492.  /* a long integer */
  493.         return mklong(sign ? -l : l);
  494.  }
  495. double1:
  496.   expo=0;
  497.   while(isdigit(CH)){
  498.  expo--;
  499.  r=r * 10.0 + (REAL)(CH - '0');
  500.  GETCHAR();
  501.         }
  502.   r=genreal(r,expo);
  503.   GETCHAR();
  504.   if((LASTCH== 'e' || LASTCH== 'E')&
  505.      (isdigit(CH)||CH== '+'||CH=='-'))goto double2;
  506.   REGET();
  507.   return mkreal( sign ? -r : r);
  508. double2:
  509.   /* scanning the exponent */
  510.   /* exponent starts with CH */
  511.   switch (CH){
  512.  case '-' : esign=true;
  513.  case '+' : GETCHAR();
  514.  }
  515.   expo=0; /* no exponent=> exponent=0 */
  516.   while(isdigit(CH)){
  517.  if(expo < 1000 )expo=expo * 10 + (CH - '0');
  518.  GETCHAR();
  519.  }
  520.   r=genreal(r, esign ? -expo : expo);
  521.   return mkreal(sign ? -r : r);
  522. }
  523. #endif
  524.  
  525. #if ! REALARITH && LONGARITH
  526. LOCAL TERM readnumber(boolean sign)
  527. {
  528.   LONG l ; int  i ;
  529.   l= (LONG)(i=LASTCH-'0');
  530.  while(isdigit(CH))
  531.       {
  532.           l=l * 10l  + (LONG)(CH -'0');
  533.           i=i * 10   + (CH -'0');
  534.           GETCHAR();
  535.        }
  536.   if(i==l) return mkint(sign ? -i : i);
  537.   else  return mklong(sign ? -l : l);
  538. }
  539. #endif
  540.  
  541. #if ! REALARITH && !LONGARITH
  542. LOCAL TERM readnumber(boolean sign)
  543. {
  544.   int  i ;
  545.   i=LASTCH-'0';
  546.   while(isdigit(CH))
  547.       {
  548.           i=i * 10   + (CH -'0');
  549.           GETCHAR();
  550.        }
  551.  return mkint(sign ? -i : i);
  552. }
  553. #endif
  554.  
  555. #if REALARITH && !LONGARITH
  556. LOCAL TERM readnumber(boolean sign)
  557. {int  i ; REAL r ;
  558.  boolean esign=false;
  559.  int expo=0;
  560.  i=LASTCH-'0';
  561.  r= (REAL)i;
  562.  while(isdigit(CH)){
  563.  i=i * 10   + (CH -'0');
  564.  r=r * 10.0 + (REAL)(CH -'0');
  565.  GETCHAR();
  566.  }
  567.   GETCHAR();
  568.   if(LASTCH== '.' && isdigit(CH))goto double1;
  569.   if((LASTCH== 'e' || LASTCH== 'E') &&
  570.      (isdigit(CH)||CH== '+'||CH=='-'))goto double2;
  571.   /* a normal integer */
  572.   REGET();
  573.   if( i <=  r-0.5) {
  574.  /* converting integer to real */
  575.  if(WARNFLAG)ws("WARNING: converting integer to real\n");
  576.  return mkreal(sign ? -r : r);
  577.  }
  578.  /* a normal integer */
  579.  return mkint(sign ? -i : i);
  580. double1:
  581.   expo=0;
  582.   while(isdigit(CH)){
  583.  expo--;
  584.  r=r * 10.0 + (REAL)(CH - '0');
  585.  GETCHAR();
  586.         }
  587.   r=genreal(r,expo);
  588.   GETCHAR();
  589.   if((LASTCH== 'e' || LASTCH== 'E') &&
  590.      (isdigit(CH)||CH== '+'||CH=='-'))goto double2;
  591.   REGET();
  592.   return mkreal( sign ? -r : r);
  593. double2:
  594.   /* scanning the exponent */
  595.   /* exponent starts with CH */
  596.   switch (CH){
  597.  case '-' : esign=true;
  598.  case '+' : GETCHAR();
  599.  }
  600.   expo=0; /* no exponent=> exponent=0 */
  601.   while(isdigit(CH)){
  602.  if(expo < 1000 )expo=expo * 10 + (CH - '0');
  603.  GETCHAR();
  604.  }
  605.   r=genreal(r, esign ? -expo : expo);
  606.   return mkreal(sign ? -r : r);
  607. }
  608. #endif
  609.  
  610. TERM READIN (void)
  611. { TERM T, X; 
  612.   ATOM A,HA,TA,XA; 
  613.   int N,TTOP; 
  614.   STATE K; PREC H;
  615.   boolean atom_is_quoted=false;
  616.  
  617.   RTOP=0;
  618.   STOP=0;
  619.   VARHWM=0;  
  620.   VARCOUNT=0;
  621.   RPUSH(MARKL,nil_atom,nil_term);
  622.   CONTEXT=OUTERK;
  623.   OPEXPECTED=false;
  624.   HIPREC=MAXPREC;
  625.   GETCHAR(); /* next char is CH */
  626.   for(;;)
  627.   { if(FILEENDED())
  628.     { if(RTOP <=1) return mkatom(END_0);
  629.        /* End of file - represented by  end. */
  630.       goto fullstop;
  631.     }
  632.     atom_is_quoted=false;
  633.     ERRPOS=CHARPOS;
  634.     GETCHAR();
  635.     switch (CHARCLASS[LASTCH]) 
  636.     { case SC:
  637.         ATOMINDEX=0; 
  638.         ATOMTAB[ATOMINDEX++]=LASTCH;
  639.         while( SC<=CHARCLASS[CH] && CHARCLASS[CH]<=DC )
  640.           { if(ATOMINDEX>=STRINGSPACE) ERROR(aSTRINGSPACEE);
  641.             ATOMTAB[ATOMINDEX++]=CH;
  642.         GETCHAR(); 
  643.       }
  644.         goto new_atom;
  645.       
  646.       case '\'':
  647.         SCANQUOTE('\''); atom_is_quoted=true;
  648.         goto new_atom;
  649.  
  650.       case '"':
  651.         SCANQUOTE('"');
  652.         ATOMTAB[ATOMINDEX++]=0;
  653.         T=LISTREP(ATOMTAB); TA=name(T); T=son(T); goto shift;
  654.  
  655.       case OC:
  656.         if(LASTCH=='/' && CH=='*')
  657.           /* A comment. Comments don't nest. */
  658.           { 
  659.             GETCHAR();
  660.             do {GETCHAR();if(FILEENDED())ERROR(COMMENTE);}
  661.             while(LASTCH!='*' || CH!='/');
  662.             GETCHAR();;
  663.             continue;
  664.           }
  665.  
  666.         if(LASTCH== '%')
  667.          /* also a comment */
  668.          { if(CH != '\n')
  669.              while(!LINEENDED()) GETCHAR();
  670.            GETCHAR();
  671.            continue;
  672.          }
  673.  
  674.         if(LASTCH=='-' && CHARCLASS[CH]==DC && !OPEXPECTED)
  675.           /* A negative number. */
  676.           { GETCHAR(); 
  677.             T=readnumber(true); TA=VART; goto shift; }
  678.  
  679.         if(LASTCH=='.' && CHARCLASS[CH]==C0)
  680.           /* A full stop. */
  681.           { 
  682.            fullstop:
  683. #if CPM
  684.         if(CH==13) GETCHAR();
  685. #endif
  686.         CHECKDELIM();
  687.             if(CONTEXT!=OUTERK) SYNERROR(BADDOTE);
  688.             if(WARNFLAG && !In_Toplevel_Read)Var_Check();
  689.             RPOP(&TA,&T); return mkfunc(TA,T);
  690.           }
  691.  
  692.         ATOMINDEX=0; 
  693.         ATOMTAB[ATOMINDEX++]=LASTCH;
  694.         while(CHARCLASS[CH]==OC)
  695.           { if(ATOMINDEX>=STRINGSPACE) ERROR(aSTRINGSPACEE);
  696.             ATOMTAB[ATOMINDEX++]=CH;
  697.         GETCHAR(); 
  698.       }
  699.         goto new_atom;
  700.  
  701.       case BC:
  702.         /* An anonymous able: replaced by a unique ordinary able. */
  703.         if(LASTCH=='_' && (CHARCLASS[CH]>DC || CHARCLASS[CH]==0))
  704.          { TA=UNBOUNDT; T=nil_term; goto shift; }
  705.  
  706.         /* ordinary variables */
  707.         T=ENTERVAR(); TA=VART; goto shift;
  708.  
  709.       case DC:
  710.         /* positiv numbers */
  711.         T=readnumber(false); TA=VART; goto shift;
  712.  
  713.  
  714.       case '(':
  715.         K=INNERK; H=MAXPREC; goto enter;
  716.  
  717.       case ')':
  718.         CHECKDELIM();
  719.         switch (CONTEXT) 
  720.         { case INNERK:
  721.             RPOP(&TA,&T); goto exit;
  722.           case FUNCK:   
  723.             /* assemble a function call */
  724.             TTOP=RTOP--;
  725.             for(N=1; TAGSTACK[RTOP]==TERML; RTOP--) N++;
  726.             RTOP=TTOP;
  727.             X=stackterms(N); TTOP=N;
  728.             while(N-->0)
  729.               { TERM ARGS; ATOM ARGA;
  730.                 RPOP(&ARGA,&ARGS);
  731.                 name(X+term_units(N))=ARGA; son(X+term_units(N))=ARGS; 
  732.               }
  733.             T=X; TA=LOOKATOM(ASTACK[RTOP],TTOP);
  734.             goto exit;
  735.           default:
  736.             SYNERROR(BADKETE);
  737.         }
  738.  
  739.       case '!':
  740.          A=CUT_0;goto get_atom;
  741.  
  742.       case '~':
  743. #if SYMBOLARITH
  744.          A=TILDE_0;goto get_atom;
  745. #endif
  746. #if !SYMBOLARITH
  747.          ATOMINDEX=0;
  748.          ATOMTAB[ATOMINDEX++]='~';
  749.      goto new_atom;
  750. #endif
  751.  
  752.       case '[':
  753.         while(CHARCLASS[CH]==C0 && !FILEENDED())GETCHAR();
  754.         if(CH==']') /* The empty list []. */
  755.           { GETCHAR(); A=NIL_0; goto get_atom; } 
  756.         
  757.         K=LISTK; H=SUBPREC; goto enter;
  758.  
  759.       case ']':
  760.         CHECKDELIM();
  761.         if(CONTEXT==LISTK) 
  762.           RPUSH(TERML,NIL_0,nil_term); 
  763.         else if(CONTEXT!=ENDLISTK) 
  764.           SYNERROR(BADKETE);
  765.         /* assemble a list */
  766.         RPOP( &TA, &T); 
  767.         do { RPOP( &XA, &X); T=mk2sons(XA,X,TA,T); TA=CONS_2; }
  768.         while(TAGSTACK[RTOP]==TERML);
  769.         goto exit;
  770.  
  771.       case '{':
  772.  while(CHARCLASS[CH]==C0 && !FILEENDED())GETCHAR();
  773.         if(CH==RBRACE) /* The 'curly' atom. */
  774.           { GETCHAR(); A=CURLY_0; goto get_atom; }
  775.         
  776.         K=CURLYK; H=MAXPREC; goto enter;
  777.  
  778.       case '}':
  779.         CHECKDELIM();
  780.         if(CONTEXT!=CURLYK) SYNERROR(BADKETE);
  781.         RPOP(&TA,&T); T=mkfunc(TA,T); TA=CURLY_1; goto exit;
  782.  
  783.       case ',':
  784.         switch(CONTEXT)
  785.         { case OUTERK: case INNERK: case CURLYK:
  786.             A=COMMA_2; goto get_atom;
  787.           case FUNCK: case LISTK:
  788.             CHECKDELIM();
  789.             OPEXPECTED=false;
  790.             HIPREC=SUBPREC;
  791.             continue;
  792.           default:
  793.             SYNERROR(BADCDDE);
  794.         }
  795.       
  796.  
  797.       case '|':
  798.         CHECKDELIM();
  799.         if(CONTEXT!=LISTK) SYNERROR(BADCDDE);
  800.         CONTEXT=ENDLISTK;
  801.         OPEXPECTED=false;
  802.         HIPREC=SUBPREC;
  803.         continue;
  804.  
  805.       case C0:
  806.         continue;
  807.  
  808.       default:
  809.         SYNERROR(WIERDCHE);
  810.     }
  811.     /* semantic actions */
  812.     new_atom:
  813.       ATOMTAB[ATOMINDEX++]=0;
  814.       A=LOOKUP(ATOMTAB,0,false);
  815.     get_atom:
  816.       if(!OPEXPECTED)
  817.       { 
  818.         if(CH=='(') /* functor in standard notation. */
  819.         { GETCHAR(); RPUSH(FUNCL,A,nil_term); 
  820.           K=FUNCK; H=SUBPREC; 
  821.           goto enterfunc;
  822.         }
  823.         if(atom_is_quoted) goto quot_atom;
  824.         HA=LOOKATOM(A,-1);
  825.         if(oclass(HA)==FXO || oclass(HA)==FYO)
  826.         { A=HA;
  827.           if(oprec(A)>HIPREC) SYNERROR(PRECE);
  828.           RPUSH(OPL,A,nil_term); 
  829.           OPEXPECTED=false; HIPREC=RPREC(A);
  830.           continue;
  831.         }
  832.         /* An atom, i.e. a functor of tarity 0. */
  833.      quot_atom:
  834.           A=LOOKATOM(A,0);
  835.           RPUSH(TERML,A,nil_term); 
  836.           OPEXPECTED=true; LOPREC=0;
  837.           continue;
  838.         }
  839.  /* OPEXPECTED ! */
  840.         if(atom_is_quoted) SYNERROR(NEEDOPE);
  841.         HA=LOOKATOM(A,-1);
  842.         if(oclass(HA)==XFO || oclass(HA)==YFO)
  843.         {  TERM Y; ATOM YA;
  844.            A=HA;
  845.            SQUASHRAND(A);
  846.            RPOP(&YA,&Y);
  847.            Y=mkfunc(YA,Y); 
  848.            RPUSH(TERML,A,Y); 
  849.            OPEXPECTED=true; LOPREC=oprec(A);
  850.            continue;
  851.         }
  852.          HA=LOOKATOM(A,-2);
  853.          if(oclass(HA)==XFXO || oclass(HA)==XFYO || oclass(HA)==YFXO)
  854.          {  A=HA;
  855.             SQUASHRAND(A);
  856.             RPUSH(OPL,A,nil_term); 
  857.             OPEXPECTED=false; HIPREC=RPREC(A);
  858.             continue;
  859.          }
  860.      else  
  861.             SYNERROR(NEEDOPE);
  862.  
  863.     shift:
  864.       if(OPEXPECTED) SYNERROR(NEEDOPE);
  865.       RPUSH(TERML,TA,T); 
  866.       OPEXPECTED=true;
  867.       LOPREC=0;
  868.       continue;
  869.     enter:
  870.       if(OPEXPECTED) SYNERROR(NEEDOPE);
  871.       RPUSH(MARKL,nil_atom,nil_term);
  872.     enterfunc: /* also called for call in standard syntax */
  873.       SAVECONTEXT();
  874.       CONTEXT=K;
  875.       OPEXPECTED=false;
  876.       HIPREC=H;
  877.       continue;
  878.     exit:
  879.       RTOP--; RPUSH(TERML,TA,T);
  880.       RESTORECONTEXT();
  881.       OPEXPECTED=true;
  882.       LOPREC=0;
  883.       continue;
  884.   }
  885.   /* ReadIn */
  886. }
  887.  
  888.  
  889. GLOBAL boolean DOREAD(void)
  890. /* read/2 */
  891. {
  892.     TERM T,TT,Q;
  893.     int i;
  894.  
  895.     if(!UNI(A0,READIN())) return false;
  896.     TT=T=mkatom(CONS_2);
  897.     for(i=0; i < VARCOUNT  ; ++i)
  898.     {
  899.         Q=mk2sons(LOOKUP(aIDENT[i],0,false),nil_term,VART,VAR_TAB[i]);
  900.         son(T)=mk2sons(ISEQ_2,Q,CONS_2,nil_term);
  901.         T=br(son(T));
  902.     }
  903.     name(T)=NIL_0;
  904.     son(T)=nil_term;
  905.     return UNI(TT,A1);
  906. }
  907.  
  908.  
  909.